home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / unitxrf.com / PROGERR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-05-20  |  5.6 KB  |  156 lines
  1. {****************************************************************************}
  2. {*                                                                          *}
  3. {*    UNIT: ProgErr and ProgErrX  (PROGERR.PAS)                             *}
  4. {*                                                                          *}
  5. {*    Donated to the Public Domain 5/20/91 by Dan Thomas CIS: 72301,2164    *}
  6. {*                                                                          *}
  7. {*  Purpose:                                                                *}
  8. {*                                                                          *}
  9. {*    This procedure will be called when TURBO encounters an I/O error      *}
  10. {*    (if I/O error detection is disabled) or a run time error.  It will    *}
  11. {*    display an appropriate error message.                                 *}
  12. {*                                                                          *}
  13. {*  ProgErr Uses: CRT -- ProgErrX does not!                                 *}
  14. {*                                                                          *}
  15. {*  Required:                                                               *}
  16. {*                                                                          *}
  17. {*    During the use of SORT.BOX (which sometimes causes a run time         *}
  18. {*    error), set PROGRAM_ERROR_DURING_SORT to true (and re-set it          *}
  19. {*    after the sort).  An appropriate error message will be displayed.     *}
  20. {*                                                                          *}
  21. {*    In addition to the above, you may call PROGRAM_I_O_ERROR passing      *}
  22. {*    it the IOResult code, and the ID of the file that the error           *}
  23. {*    occurred on.  An appropriate message will be displayed, and the       *}
  24. {*    program halted.                                                       *}
  25. {*                                                                          *}
  26. {*    Another procedure available is FATAL_ERROR.  Pass it en error         *}
  27. {*    message.  It will terminate the program.                              *}
  28. {*                                                                          *}
  29. {*    A function that is available is ERROR_DESC.  Pass it the IOResult     *}
  30. {*    code, and it will return a descriptive message.                       *}
  31. {*                                                                          *}
  32. {****************************************************************************}
  33.  
  34. UNIT PROGERR;
  35.  
  36. INTERFACE
  37. {============================================================================}
  38.  
  39. USES CRT;
  40.  
  41. CONST
  42.   program_error_during_sort : boolean = false;
  43.  
  44. PROCEDURE PROGRAM_I_O_ERROR(error_nbr : integer;
  45.                             file_id   : string);
  46.  
  47. PROCEDURE FATAL_ERROR(msg : string);
  48.  
  49. FUNCTION ERROR_DESC(error_nbr : integer) : string;
  50.  
  51. {============================================================================}
  52. IMPLEMENTATION
  53.  
  54. VAR
  55.   save_exitproc : pointer;
  56.  
  57. PROCEDURE RESET_SCREEN;
  58.  
  59. begin
  60.   Window(1,1,80,25);
  61.   GotoXY(1,25);
  62.   writeln;
  63. end; {reset_screen}
  64.  
  65. PROCEDURE FATAL_ERROR(msg : string);
  66.  
  67. begin
  68.   reset_screen;
  69.   writeln(^G,'Fatal error: ',msg);
  70.   halt(1);
  71. end; {fatal_error}
  72.  
  73. FUNCTION ERROR_DESC(error_nbr : integer) : string;
  74.  
  75. var
  76.   s : string;
  77.  
  78. begin
  79.   case error_nbr of
  80.     2   : error_desc := 'File not found';
  81.     3   : error_desc := 'Path not found';
  82.     4   : error_desc := 'Too many open files';
  83.     5   : error_desc := 'Access denied';
  84.     16  : error_desc := 'Cannot remove current directory';
  85.     17  : error_desc := 'Cannot rename accross drives';
  86.     100 : error_desc := 'Disk read error';
  87.     101 : error_desc := 'Disk write error';
  88.     106 : error_desc := 'Invalid numeric format';
  89.     150 : error_desc := 'Disk is write-protected';
  90.     152 : error_desc := 'Drive not ready';
  91.     154 : error_desc := 'CRC error in data';
  92.     156 : error_desc := 'Disk seek error';
  93.     158 : error_desc := 'Sector not found';
  94.     159 : error_desc := 'Printer out of paper';
  95.     160 : error_desc := 'Device write fault';
  96.     161 : error_desc := 'Device_read_fault';
  97.     162 : error_desc := 'Hardware failure';
  98.     200 : error_desc := 'Division by zero';
  99.     202 : error_desc := 'Stack overflow';
  100.     203 : error_desc := 'Heap overflow (not enough memory)';
  101.     205 : error_desc := 'Floating point overflow';
  102.     206 : error_desc := 'Floating point underflow';
  103.     207 : error_desc := 'Invalid floating point operation';
  104.   else
  105.     str(error_nbr,s);
  106.     error_desc := 'Error number ' + s;
  107.   end; {of case}
  108. end; {error_desc}
  109.  
  110. PROCEDURE PROGRAM_I_O_ERROR(error_nbr : integer;
  111.                             file_id   : string);
  112.  
  113. begin
  114.   reset_screen;
  115.   if file_id = '' then
  116.     writeln(^G,'I/O error = ',error_desc(error_nbr))
  117.   else
  118.     writeln(^G,'I/O error on file ',file_id,': ',error_desc(error_nbr));
  119.   halt(error_nbr);
  120. end; {program_i_o_error}
  121.  
  122. PROCEDURE PROCESS_I_O_ERROR;
  123.  
  124. begin
  125.   writeln(^G,'I/O error = ',error_desc(ExitCode));
  126. end; {process_i_o_error}
  127.  
  128. PROCEDURE PROCESS_RUN_TIME_ERROR;
  129.  
  130. begin
  131.   writeln(^G,'Run time error = ',error_desc(ExitCode));
  132. end; {process_run_time_error}
  133.  
  134. {$f+}
  135. PROCEDURE PROGRAM_ERROR;
  136.  
  137. begin
  138.   ExitProc := save_exitproc;
  139.   if (ExitCode <> 0) and (ErrorAddr <> nil) then
  140.     begin
  141.       reset_screen;
  142.       if ExitCode < 200 then
  143.         process_i_o_error
  144.       else
  145.         process_run_time_error;
  146.       ErrorAddr := nil;
  147.     end;
  148. end; {program_error}
  149. {$f-}
  150.  
  151.  
  152. begin {initialization}
  153.   save_exitproc := ExitProc;
  154.   ExitProc      := @program_error;
  155. end.
  156.